Shareware Overload Trio 2/Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO/dir41/tsrsrc35.zip/XMS.PAS

Pascal/Delphi Source File | 1993-10-21 | 10KB | 390 lines

{**************************************************************************
*   XMS - unit of XMS functions                                           *
*   Copyright (c) 1991,1993 Kim Kokkonen, TurboPower Software.            *
*   May be freely distributed and used but not sold except by permission. *
*                                                                         *
*   Version 3.0 9/24/91                                                   *
*     first release                                                       *
*   Version 3.1 11/4/91                                                   *
*     no change                                                           *
*   Version 3.2 11/22/91                                                  *
*     add AllocateUmbMem, FreeUmbMem functions                            *
*   Version 3.3 1/8/92                                                    *
*     no change                                                           *
*   Version 3.4 2/14/92                                                   *
*     fix unreported bug in GetMem call in function GetXmsHandles         *
*     add AllocateHma and FreeHma functions                               *
*   Version 3.5 10/18/93                                                  *
*     no change                                                           *
***************************************************************************}

{$R-,S-,I-,V-,B-,F-,A-,E-,N-,G-,X-}

unit Xms;
  {-XMS functions needed for TSR Utilities}

interface

const
  ExhaustiveXms : Boolean = False;

type
  XmsHandleRecord =
  record
    Handle : Word;
    NumPages : Word;
  end;
  XmsHandles = array[1..16380] of XmsHandleRecord;
  XmsHandlesPtr = ^XmsHandles;

function XmsInstalled : Boolean;
  {-Returns True if XMS memory manager installed}

function QueryFreeExtMem(var TotalFree, LargestBlock : Word) : Byte;
  {-Return info about free XMS (in k bytes)}

function GetHandleInfo(XmsHandle : Word;
                       var LockCount    : Byte;
                       var HandlesLeft  : Byte;
                       var BlockSizeInK : Word) : Byte;
  {-Return info about specified Xms handle}

function AllocateExtMem(SizeInK : Word; var XmsHandle : Word) : Byte;
  {-Allocate XMS memory}

function FreeExtMem(XmsHandle : Word) : Byte;
  {-Free XMS memory}

function AllocateUmbMem(SizeInP : Word; var Segment, Size : Word) : Byte;
  {-Allocate UMB memory}

function FreeUmbMem(Segment : Word) : Byte;
  {-Deallocate UMB memory}

function AllocateHma(SizeInB : Word) : Byte;
  {-Allocate the HMA, requesting SizeInB bytes}

function FreeHma : Byte;
  {-Free the HMA}

function GetXmsHandles(var XmsPages : XmsHandlesPtr) : Word;
  {-Return number of XMS handles allocated, and pointer to array of handle records}

function ExtMemPossible : Boolean;
  {-Return true if raw extended memory is possible}

function ExtMemTotalPrim : LongInt;
  {-Returns total number of bytes of extended memory in the system}

{=======================================================================}

implementation

var
  XmsControl       : Pointer;          {ptr to XMS control procedure}

  function XmsInstalled : Boolean;
    {-Returns True if XMS memory manager installed}
  begin
    XmsInstalled := (XmsControl <> nil);
  end;

  function XmsInstalledPrim : Boolean; assembler;
    {-Returns True if an XMS memory manager is installed}
  asm
    mov ah,$30
    int $21
    cmp al,3
    jae @Check2F
    mov al,0
    jmp @Done
@Check2F:
    mov ax,$4300
    int $2F
    cmp al,$80
    mov al,0
    jne @Done
    inc al
@Done:
  end;

  function XmsControlAddr : Pointer; assembler;
    {-Return address of XMS control function}
  asm
    mov ax,$4310
    int $2F
    mov ax,bx
    mov dx,es
  end;

  function QueryFreeExtMem(var TotalFree, LargestBlock : Word) : Byte; assembler;
    {-Return info about free XMS}
  asm
    mov ah,$08
    call dword ptr [XmsControl]
    or ax,ax
    jz @Done
    les di,TotalFree
    mov es:[di],dx
    les di,LargestBlock
    mov es:[di],ax
    xor bl,bl
@Done:
    mov al,bl
  end;

  function GetHandleInfo(XmsHandle : Word;
                         var LockCount    : Byte;
                         var HandlesLeft  : Byte;
                         var BlockSizeInK : Word) : Byte; assembler;
    {-Return info about specified Xms handle}
  asm
    mov ah,$0E
    mov dx,XmsHandle
    call dword ptr [XmsControl]
    test ax,1
    jz @Done
    les di,LockCount
    mov byte ptr es:[di],bh
    les di,HandlesLeft
    mov byte ptr es:[di],bl
    les di,BlockSizeInK
    mov es:[di],dx
    xor bl,bl
@Done:
    mov al,bl
  end;

  function AllocateExtMem(SizeInK : Word; var XmsHandle : Word) : Byte; assembler;
    {-Allocate XMS memory}
  asm
    mov ah,$09
    mov dx,SizeInK
    call dword ptr [XmsControl]
    test ax,1
    jz @Done
    les di,XmsHandle
    mov es:[di],dx
    xor bl,bl
@Done:
    mov al,bl
  end;

  function FreeExtMem(XmsHandle : Word) : Byte; assembler;
    {-Free XMS memory}
  asm
    mov ah,$0A
    mov dx,XmsHandle
    call dword ptr [XmsControl]
    test ax,1
    jz @Done
    xor bl,bl
@Done:
    mov al,bl
  end;

  function AllocateUmbMem(SizeInP : Word; var Segment, Size : Word) : Byte; assembler;
  asm
    mov ah,$10
    mov dx,SizeInP
    call dword ptr [XmsControl]
    les di,Size
    mov es:[di],dx            {return size of allocated block or largest block}
    test ax,1
    jz @Done
    les di,Segment
    mov es:[di],bx            {return segment}
    xor bl,bl                 {no error}
@Done:
    mov al,bl                 {return error result}
  end;

  function FreeUmbMem(Segment : Word) : Byte; assembler;
  asm
    mov ah,$11
    mov dx,Segment
    call dword ptr [XmsControl]
    test ax,1
    jz @Done
    xor bl,bl
@Done:
    mov al,bl
  end;

  function AllocateHma(SizeInB : Word) : Byte; assembler;
  asm
    mov dx,SizeInB
    mov ah,1
    call dword ptr [XmsControl]
    or ax,ax
    jz @Done
    xor bl,bl
@Done:
    mov al,bl
  end;

  function FreeHma : Byte; assembler;
  asm
    mov ah,2
    call dword ptr [XmsControl]
    or ax,ax
    jz @Done
    xor bl,bl
@Done:
    mov al,bl
  end;

  function GetXmsHandles(var XmsPages : XmsHandlesPtr) : Word;
    {-Return number of XMS handles allocated, and pointer to array of handle records}
  var
    H : Word;
    H0 : Word;
    H1 : Word;
    HCnt : Word;
    FMem : Word;
    FMax : Word;
    HMem : Word;
    LockCount : Byte;
    HandlesLeft : Byte;
    Delta : Integer;
    Status : Byte;
    Done : Boolean;

    procedure ExhaustiveSearchHandles(var Handles : Word; XmsPages : XmsHandlesPtr);
      {-Search handles exhaustively}
    var
      H : Word;
      HCnt : Word;
    begin
      HCnt := 0;
      for H := 0 to 65535 do
        if GetHandleInfo(H, LockCount, HandlesLeft, HMem) = 0 then begin
          inc(HCnt);
          if XmsPages <> nil then
            with XmsPages^[HCnt] do begin
              Handle := H;
              NumPages := HMem;
            end;
        end;
      Handles := HCnt;
    end;

  begin
    GetXmsHandles := 0;

    Status := QueryFreeExtMem(FMem, FMax);
    if Status = $A0 then begin
      FMem := 0;
      FMax := 0;
    end else if Status <> 0 then
      Exit;

    if ExhaustiveXms then begin
      {Search all 64K XMS handles for valid ones}
      HCnt := 0;
      ExhaustiveSearchHandles(HCnt, nil);
      if HCnt <> 0 then begin
        GetMem(XmsPages, HCnt*SizeOf(XmsHandleRecord));
        ExhaustiveSearchHandles(HCnt, XmsPages);
        GetXmsHandles := HCnt;
      end;

    end else begin
      {Heuristic algorithm to find used handles quickly}

      {Allocate two dummy handles}
      if FMem > 1 then
        HMem := 1
      else
        HMem := 0;
      Status := AllocateExtMem(HMem, H0);
      if Status <> 0 then
        Exit;
      Status := AllocateExtMem(HMem, H1);
      if Status <> 0 then begin
        {Deallocate dummy handle}
        Status := FreeExtMem(H0);
        Exit;
      end;
      Delta := H1-H0;
      {Deallocate one dummy}
      Status := FreeExtMem(H1);

      {Trace back through valid handles, counting them}
      HCnt := 0;
      H1 := H0;
      repeat
        Status := GetHandleInfo(H1, LockCount, HandlesLeft, HMem);
        Done := (Status <> 0);
        if not Done then begin
          dec(H1, Delta);
          inc(HCnt);
        end;
      until Done;

      if HCnt > 1 then begin
        dec(HCnt);
        GetMem(XmsPages, HCnt*SizeOf(XmsHandleRecord));
        {Go forward again through valid handles, saving them}
        inc(H1, Delta);
        H := 0;
        while H1 <> H0 do begin
          Status := GetHandleInfo(H1, LockCount, HandlesLeft, HMem);
          if Status = 0 then begin
            inc(H);
            with XmsPages^[H] do begin
              Handle := H1;
              NumPages := HMem;
            end;
          end;
          inc(H1, Delta);
        end;
        GetXmsHandles := HCnt;
      end;

      {Deallocate dummy handle}
      Status := FreeExtMem(H0);
    end;
  end;

  function DosVersion : Byte; Assembler;
    {-Return major DOS version number}
  asm
    mov     ah,$30
    int     $21
  end;

  function ExtMemPossible : Boolean;
    {-Return true if raw extended memory is possible}
  const
    ATclass = $FC;              {machine ID bytes}
    Model80 = $F8;
  var
    MachineId : Byte absolute $FFFF : $000E;
  begin
    {don't allow allocation if running PC or XT, or under DOS 2.x or OS/2}
    ExtMemPossible := False;
    case DosVersion of
      3..5 :
        case MachineId of
          ATclass, Model80 : ExtMemPossible := True;
        end;
    end;
  end;

  function ExtMemTotalPrim : LongInt; assembler;
    {-Returns total number of bytes of extended memory in the system}
  asm
    mov ah,$88
    int $15
    mov cx,1024
    mul cx
  end;

begin
  if XmsInstalledPrim then
    XmsControl := XmsControlAddr
  else
    XmsControl := nil;
end.